

;;; ===============================================================
;;;							
;;;	    Code for Pseudo Unification Grammar Formalism
;;; 	    ---------------------------------------------
;;;                	  Masaru Tomita		
;;; 		  Center for Machine Translation
;;; 		   Carnegie-Mellon University
;;;			  February 1988
;;; 			   Version 3-2
;;;				
;;; ================================================================

;;; ----------------------------------------------------------------
;;;
;;; 	The following file is required:
;;; 		util.lisp for MAP-DOLIST, APPEND-DOLIST, OR-DOLIST
;;; 
;;;   HISTORY
;;; 
;;; 27-Jan-88 	Masaru Tomita (mt) at Carnegie-Mellon University
;;;	Created from v7.6, removing all semantic stuff.
;;; 23-Feb-88   Masaru Tomita (mt) at Carnegie-Mellon University
;;;     Merge all compilation functions.
;;; ________________________________________________________________
;;; 

;;; ________________________________________________________________
;;;
;;;   Global Variable declarations and initializations
;;; ________________________________________________________________
;;; 

;;; 
;;; *FS-LIST* - a list of all possible f-structures built so far.
;;; 
(defvar *fs-list*) 


;;; ________________________________________________________________
;;; 
;;;    Miscellaneous Functions
;;; ________________________________________________________________

;;; 
;;; CONSTIT-LIST - used in the following function, RESISTERP.
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;; 
;;;  RESISTERP returns t if x is one of x0, x1, x2, x3,...
;;; 
(defun resisterp (x)
  (member x CONSTIT-LIST))

;;; 
;;;  PATHP returns t if x is a path.
;;; 
(defun pathp (x)
  (and (listp x) (resisterp (car x))))

(defmacro map-dolist+ (varlist body)
 `(remove '*FAIL* (map-dolist ,varlist ,body)))

;;; _____________________________________________________________
;;; 
;;;   Type Conversion Functions
;;; _____________________________________________________________
;;; 

;;; 
;;; LIST-TO-VALUE converts a list of values into a value.
;;; (a b c) ==> (*OR* a b c)
;;; (a)     ==>  a
;;;
(defun list-to-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*OR* v-list))))

;;; 
;;; VALUE-TO-LIST is inverse LIST-TO-VALUE
;;; (*OR* a b c) ==> (a b c)
;;;  a  ==>  (a)
;;;
(defun value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*OR*)(cdr v))
        (t (list v))))

;;; 
;;; LIST-TO-MULTI-VALUE converts a list of values into a multi-value.
;;; (a b c) ==> (*MULTIPLE* a b c)
;;; (a)     ==>  a
;;;
(defun list-to-multi-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*MULTIPLE* v-list))))

;;; 
;;; MULTI-VALUE-TO-LIST is inverse LIST-TO-MULTI-VALUE
;;; (*MULTIPLE* a b c) ==> (a b c)
;;;  a  ==>  (a)
;;;
(defun multi-value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*MULTIPLE*)(cdr v))
        (t (list v))))

;;; 
;;; POP-MULTI-VALUE removes the first element of a multi-value.
;;; (pop-multi-value '(*MULTIPLE* a b c)) --> (*MULTIPLE* b c)
;;; 
(defun pop-multi-value (v)
  (setq v (multi-value-to-list v))
  (if (null v) '*FAIL*
      (list-to-multi-value (cdr v))))

;;; 
;;;  VAL type indentifier
;;;
;;;   NULL	nil
;;;   ATOM	atom value
;;;   OR        (*OR* ......)
;;;   NOT       (*NOT* .....)
;;;   MULTI     (*MULTIPLE* ...)
;;;   FS        f-structure
;;;   USER	User-defined special type
;;;
(defun fs-type (fs)
  (cond ((null fs) 'NULL)
        ((atom fs) 'ATOM)
	((eq (car fs) '*OR*) 'OR)
	((eq (car fs) '*NOT*) 'NOT)
        ((eq (car fs) '*MULTIPLE*) 'MULTI)
	((atom (car fs)) 'USER)
        (t 'FS)))

;;; 
;;; Macros for checking types.
;;; 
(defmacro or-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*OR*)))
(defmacro multi-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*MULTIPLE*)))
(defmacro not-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*NOT*)))
(defmacro user-p (fs)
  `(and (not (atom ,fs))(atom (car ,fs))))

;;; _____________________________________________________________
;;; 
;;;   Error handling functions
;;; _____________________________________________________________
;;; 

;;; 
;;;  EQUATION-ERROR
;;; 
(defun equation-error (object)
  (format t "~%### INVALID EQUATION ~S~%" object)
  nil)


;;; _____________________________________________________________
;;; 
;;;  Handling of PSEUDO equations
;;; _____________________________________________________________
;;; 

;;; 
;;;  Top level macros
;;; 
(defmacro p=p (path1 path2)
  `(setq x (path=path x ',path1 ',path2)))
(defmacro p=a (path atom)
  `(setq x (path=atom x ',path ',atom)))
(defmacro p=d (path)
  `(setq x (path=defined x ',path)))
(defmacro p=u (path)
  `(setq x (path=undefined x ',path)))
(defmacro p=r (path)
  `(setq x (path=remove x ',path)))
(defmacro p=ca (path atom)
  `(setq x (path=catom x ',path ',atom)))
(defmacro p>p (path1 path2)
  `(setq x (path>path x ',path1 ',path2)))
(defmacro p>a (path atom)
  `(setq x (path>atom x ',path ',atom)))
(defmacro p=l (path lispcode)
  `(setq x (path=lispcode x ',path ',lispcode)))
(defmacro p==p (path1 path2)
  `(setq x (path=remove
		(path=path (path=defined x ',path2) ',path1 ',path2)
	        ',path2)))
(defmacro p<p (path1 path2)
  `(setq x (path<path x ',path1 ',path2)))
(defmacro p<a (path atom)
  `(setq x (path<atom x ',path ',atom)))


;;; 
;;;   The following functions do the actual handling of PSEUDO
;;;  equations.
;;;
;;;  function    	example equations
;;; 
;;;  PATH=PATH 		((x0 subj) = x1), ((x1 agr) = (x2 agr)), ...
;;;  PATH=ATOMS 	((x0 mood) = imp), ((x1 tense) = (*OR* pres future))
;;;  PATH=DEFINED	((x0 obj) = *DEFINED*)
;;;  PATH=UNDEFINED	((x0 obj) = *UNDEFINED*)
;;;  PATH>PATH		((x0 ppadjunct) > x2)
;;;  PATH>ATOMS		((x0 aux) > possibility)
;;;  PATH=LISPCODE      ((x0 value) <= (+ (x2 value)(* 10 (x1 value))))
;;; 
;;;   The followings are particularly useful for generation.
;;;  PATH=REMOVE	((x0 obj) = *REMOVE*)
;;;  PATH<PATH
;;  PATH<ATOM
;;; 

(defun path=path (*fs-list* path1 path2 &aux unpacked)
    ;; unpack all f-structures so we won't have to worry about
    ;; disjunction during unification
 (setq unpacked (unpack* *fs-list* path2))
    ;; Unpack path2. If it fails due to *MULTIPLE*, try unpack path1.
    ;; If both unpackings fail, error.
 (cond ((eq unpacked '*fail*)
	(setq unpacked (unpack* *fs-list* path1))
	(cond ((eq unpacked '*fail*)
	       (format t "### (~S = ~S). Both contain *MUTLIPLE*."
		   path1 path2)
	       (return-from path=path nil))
	      (t
	       (map-dolist+ (fs unpacked)
		  (setvalue fs path2 (getvalue fs path1) :mode 'UNIFY))
	      )))
       (t 
        (map-dolist+ (fs unpacked)
             (setvalue fs path1 (getvalue fs path2) :mode 'UNIFY)))))

(defun path>path (*fs-list* path1 path2 &aux unpacked)
 (setq unpacked (unpack* *fs-list* path2))
 (cond ((eq unpacked '*fail*)
        (format t "### (~S > ~S).  Thr right path contains *MULTIPLE*"
		path1 path2)
	(return-from path>path nil)))
 (map-dolist+ (fs unpacked)
       (setvalue fs path1 (getvalue fs path2) :mode 'PUSH))) 

(defun path=atom (*fs-list* path atom)
       ;; Do unification and set the result
    (map-dolist+ (fs *fs-list*)
       (setvalue fs path atom :mode 'UNIFY)))
	     
(defun path=defined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'DEFINED)))

(defun path=undefined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'UNDEFINED)))

(defun path=catom (*fs-list* path atom)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path atom :mode 'C-UNIFY)))

(defun path>atom (*fs-list* path atom)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path atom :mode 'PUSH)))

(defun path=remove (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'REMOVE)))

;; 26-Jul-96 violetta: here is where we need to look at why
;; testing the values *DEFINED* and *UNDEFINED* after
;; popping doesn't work.
(defun path<path (*fs-list* path1 path2 &aux unpacked)
 (setq unpacked (unpack* *fs-list* path2))
 (cond ((eq unpacked '*fail*)
        (format t "### (~S < ~S).  Thr right path contains *MULTIPLE*"
		path1 path2)
	(return-from path<path nil)))
 (map-dolist+ (fs unpacked)
      (let ((value (multi-value-to-list (getvalue fs path2))))
	(cond ((null value)
	       (return-from path<path nil))
	      (t 
               (setq fs (setvalue fs path1 (car value) :mode 'UNIFY))
	       (setvalue fs path2 nil :mode 'POP)
	)))))
   
;;; 
;;; PATH=LISPCODE - it uses COMPILE-LISPCODE defined below.
;;;
(defun path=lispcode (*fs-list* path expr)
 
     ;; Unpack for all paths in the lisp code (EXPR) 
  (dolist (getpath (find-paths expr))
    (setq *fs-list* (unpack* *fs-list* getpath)))

     ;;  Then GETVALUE all paths, apply the lisp code, and SETVALUE
     ;;  the result into PATH.
     ;;  Example: (setvalue fs '(x0) (+ (getvalue fs '(x2 value))
     ;;					(* 10 (getvalue fs '(x1 value)))))
     
  (map-dolist (fs *fs-list*)
    (setvalue fs path
	      (apply (coerce `(lambda (fs) ,(compile-lispcode expr))
			     'function)
		;was (apply `(lambda (fs) ,(compile-lispcode expr))
		     (list fs)))))


;;; _________________________________________________________________
;;;
;;; COMPILE-LISPCODE compiles (arbitrary lisp codes) equations
;;; _________________________________________________________________
;;; 
(defun compile-lispcode (expr)
  (cond ((atom expr) expr)
	((eq 'QUOTE (car expr)) expr)
	((pathp expr) `(getvalue fs ',expr))
	(t (map-dolist (e expr) (compile-lispcode e)))))

; function to isolate all (x0 ...) or (x1 ...) paths in an s-expr.

(defun find-paths (expr)
  (cond ((atom expr) nil)
	((eq 'QUOTE (car expr)) nil)
	((pathp expr) (list expr))
	(t (mapcan #'(lambda (sub-expr) (find-paths sub-expr))
		   expr))))


;;; _________________________________________________________________
;;;
;;;  COMPILE-STATEMENT - Actual compilation of a statement.
;;;   Returns a lisp function for it.
;;; _________________________________________________________________

(defun compile-statement (statement)
  (let ((part1 (first  statement))
	(part2 (second statement))
	(part3 (third  statement)))
  ; 
  ;   If it is a disjunctive statement
  ; 
    (cond ((eq part1 '*OR*)
	   `(setq x
	      (append
		,@(map-dolist (s (rest statement))
		   `(let ((x x))
			,(compile-statements s))))))
  ; 
  ;   If it is an exclusive OR statement
  ; 
          ((eq part1 '*EOR*)
	   `(setq x
	      (append-dolist (fs x)
 	       (or
		,@(map-dolist (s (rest statement))
		   `(let ((x (list fs)))
			 ,(compile-statements s)))))))
  ; 
  ;   If it is an CASE statement
  ; 
          ((eq part1 '*CASE*)
	   `(setq x
	     (append-dolist (fs x)
	      (case ,(compile-lispcode part2)
	        ,@(map-dolist (s (cddr statement))
		   `(,(car s) (let ((x (list fs)))
				,(compile-statements (cdr s)))))))))
  ; 
  ;   If it is a TEST statement	;  need to change to unpack.
  ; 
          ((eq part1 '*TEST*)
	   `(let ()
	      (setq x
	        (append-dolist (getpath ',(find-paths part2))
		  (completely-unpack* x getpath)))
	      (setq x
		(append-dolist (fs x)
		  (and ,(compile-lispcode part2) (list fs))))))
  ; 
  ;   If it is an INTERPRET statement ; need to change to unpack.
  ; 
	  ((eq part1 '*INTERPRET*)
	   `(setq x
		(append-dolist (fs x)
		  (interpret-statements (list fs)
		   (apply (coerce (lambda (fs) ,(compile-lispcode part2))
				  'function)
			  (list fs))))))

					;   had been `(lambda (fs) ,(c-l p2))
  ; 
  ;   If length of statement is 3 and part1 is a path, then equation.
  ; 
	  ((= (length statement) 3)
           (compile-equation statement))
  ; 
  ;   Otherwise, error.
  ; 
          (t (equation-error statement)))))

;;; _________________________________________________________________
;;; 
;;;  COMPILE-EQUATION takes a pseudo equation and returns a lisp
;;;  code for it.
;;; _________________________________________________________________
;;; 
(defun compile-equation (equation)
  (let ((part1 (first  equation))
	(part2 (second equation))
	(part3 (third  equation)))
  ; 
  ;   Xn  -->  (Xn)
  ;
    (if (resisterp part1) (setq part1 (list part1)))
    (if (resisterp part3) (setq part3 (list part3)))

  ; 
  ;   Branch by part2
  ; 
	   (case part2
	     (=
	       (cond ((pathp part3)
		      `(P=P ,part1 ,part3))
		     ((eq part3 '*DEFINED*)
		      `(P=D ,part1))
		     ((eq part3 '*UNDEFINED*)
		      `(P=U ,part1))
		     ((eq part3 '*REMOVE*)
		      `(P=R ,part1))
		     ((or (atom part3) (atom (car part3)))
		      `(P=A ,part1 ,part3))
		     (t (equation-error equation))))

	     (=c
	      (cond ((pathp part3)
		     (equation-error equation))
		    ((or (atom part3) (atom (car part3)))
		     `(P=CA ,part1 ,part3))
		     (t (equation-error equation))))

	     (>
	       (cond ((pathp part3)
		      `(P>P ,part1 ,part3))
		     ((or (atom part3) (atom (car part3)))
		      `(P>A ,part1 ,part3))
		     (t (equation-error equation))))

	     (<=
	       `(P=L ,part1 ,part3))

 	     (==
	       (cond ((pathp part3)
		      `(P==P ,part1 ,part3))
		     (t (equation-error equation))))

	     (<
	       (cond ((pathp part3)
		      `(P<P ,part1 ,part3))
		     ((or (atom part3) (atom (car part3)))
		      `(P<A ,part1 ,part3))
		     (t (equation-error equation))))
	     (t
	       (cond ((member part2 *user-defined-equation*)
		      (compile-statements
		        (macroexpand (list part2 part1 part3))))
		     (t (equation-error equation)))))))

;;;
;;;	COMPILE-STATEMENTS
;;;     Returns a list of lisp functions
;;;
(defun compile-statements (statements)
 `(and
   ,@(map-dolist (statement statements)
	(compile-statement statement))))

;;; __________________________________________________________
;;; 
;;;   Functions to Interpret (Evaluate) Pseudo Equations
;;; __________________________________________________________
;;; 

;;; 
;;;  INTERPRET-EQUATION executes one equation.
;;; 
(defun interpret-equation (x equation)
  (apply `(lambda (x) ,(compile-equation equation)) (list x)))

;;; 
;;;  INTERPRET-LISPCODE evaluates a lisp expression possibly
;;;  with paths inside.
;;; 
(defun interpret-lispcode (fs expr)
  (apply `(lambda (fs) ,(compile-lispcode expr)) (list fs)))

;;; 
;;;  INTERPRET-STATEMENT executes one statement.
;;; 
(defun interpret-statement (x statement)
  (let ((part1 (first statement))
	(part2 (second statement))
    	(part3 (third statement)))
  ; 
  ;   If it is a disjunctive statement
  ; 
    (cond ((eq part1 '*OR*)
	   (setq x
	      (append-dolist (s (rest statement))
		 (interpret-statements x s))))
  ; 
  ;   If it is an exclusive OR statement
  ; 
          ((eq part1 '*EOR*)
	   (setq x
	      (append-dolist (fs x)
		(or-dolist (s (rest statement))
		   (interpret-statements (list fs) s)))))
  ; 
  ;   If it is an CASE statement
  ; 
          ((eq part1 '*CASE*)
	   (append-dolist (fs x)
	       (let ((key (interpret-lispcode fs part2)))
		  (interpret-statements (list fs)
					(cdr (assoc key (cddr statement))))
	       )))
  ; 
  ;   If it is an exclusive TEST statement
  ; 
          ((eq part1 '*TEST*)
           (setq x 
	     (append-dolist (getpath (find-paths part2))
		    (completely-unpack* x getpath)))
           (append-dolist (fs x)
		  (and (interpret-lispcode fs part2) (list fs))))

;;;   If it is a recursive evaluation of equations
;;; 
	  ((eq part1 '*INTERPRET*)
           (append-dolist (fs x)
		  (interpret-statements
			   (list fs) (interpret-lispcode fs part2))))

  ; 
  ;   If length of statement is 3 and part1 is a path, then equation.
  ; 
	  ((= (length statement) 3)
           (interpret-equation x statement))
  ; 
  ;   Otherwise, error.
  ; 
          (t (equation-error statement)))))
 
;;; 
;;;  INTERPRET-STATEMENTS executes a list of statements.
;;; 
(defun interpret-statements (x statements)
  (and-dolist (statement statements)
	(setq x (interpret-statement x statement))))
    


;;; _________________________________________________________________
;;; 
;;;  Unpacking a packed f-structure.  Returns a fs-list,
;;;  or *FAIL*, if it can't unpack (with *MULTIPLE*)
;;; _________________________________________________________________
;;; 
(defun unpack* (fs-list path)
	 (append-dolist (fs fs-list)
	   (let ((result (unpack fs path)))
	    (if (eq result '*fail*) (return-from unpack* '*fail*) result))))

(defun unpack (fs path)			; returns a fs-list or *FAIL*
  (prog (sub-fs unpacked-sub-fs-list)
       ;; if (length path) is 1, no need to unpack
	(if (equal (length path) 1) (return (value-to-list fs)))
       ;; if fs is a *MULTIPLE* value, fail.				 
  	(if (eq (car fs) '*MULTIPLE*) (return '*fail*))
       ;; get sub f-structure
    (setq sub-fs (second (assoc (car path) fs)))
       ;; if sub-fs is undefined, no need to unpack
    (if (null sub-fs) (return (list fs)))
    (if (not (listp sub-fs)) (return (list fs))) ;;tomabech

    (setq unpacked-sub-fs-list
        (cond
             ;; if sub-fs is a *OR* list
          ((eq (car sub-fs) '*OR*)
            (append-dolist (sub-fs-1 (cdr sub-fs))
	      (let ((result (unpack sub-fs-1 (cdr path))))
		(if (eq result '*fail*)
		    (return-from unpack '*fail*)
		    result))))
             ;; if sub-fs is a *MULTIPLE* value
          ((eq (car sub-fs) '*MULTIPLE*)
	   (return-from unpack '*fail*))
             ;; if sub-fs is a single value
          (t
           (unpack sub-fs (cdr path)))))
    (return
      (map-dolist (unpacked-sub-fs unpacked-sub-fs-list)
        (setvalue fs (list (car path)) unpacked-sub-fs)))))

;;;
;;;  UNPACK* does not unpack the last slot of PATH, while
;;;  COMPLETELY-UNPACK* does.  Used for *TEST* and *INTERPRET*
;;;  statements.
;;;
(defun completely-unpack* (fs-list path)
  (unpack* fs-list (append path '(DUMMY))))

;;; __________________________________________________________________
;;; 
;;;  GETVALUE gets a value from a f-structure.
;;;  No need to worry about *OR*, as already unpacked.
;;; __________________________________________________________________
;;; 
(defun getvalue (fs path)   ; returns a fs; or nil if undefined
 (cond ((not (listp fs)) nil)
       (t (let ((assoc-result (second (assoc (car path) fs))))
           (cond 
        ;; if assoc-result is nil, return nil
             ((null assoc-result) nil)
        ;; if path length is 1, return assoc-result
             ((eq (length path) 1) assoc-result)
        ;; otherwise call getvalue recursively
             (t (getvalue assoc-result (cdr path))))))))

;;;
;;;  GETVALUE* is used at the end of each augmentation function.
;;;
(defun getvalue* (fs-list path)
    (list-to-value   
	(append-dolist (fs fs-list)
	   (value-to-list (getvalue fs path)))))

;;; __________________________________________________________________
;;; 
;;; SETVALUE
;;;  Setting a value (val) to a particular slot (path) of
;;;  a f-structure (fs).
;;; __________________________________________________________________
;;; 
;;;  There are 8 modes as follow:
;;; 
;;; OVERWRITE (default)  for ((xn ..) <= value)
;;;  If a value already exists, overwrite.
;;;
;;; UNIFY  for ((xn ..) = value)
;;;  If a value already exists, unify it with the new value.
;;;  If unify returns *FAIL*, then fail.
;;;
;;; C-UNIFY  for ((xn ..) =c value)
;;;  Same as UNIFY mode, except it fails if a value doesn't
;;;  already exists.
;;;
;;; DEFINED  for ((xn ..) = *DEFINED*)
;;;  If a value doesn't already exists, fail.
;;;  Otherwise, return fs.  Argument val is dummy.
;;;
;;; UNDEFINEDP   for ((xn ..) = *UNDEFINED*)
;;;  If a value already exists, fail.
;;;  Otherwise, return fs. Argument val is dummy.
;;;
;;; PUSHVALUE  for ((xn ..) > value)
;;;  If values already exists, append val to them.
;;;
;;; REMOVE  for ((x0 ..) = *REMOVE*) or ((xn ..) == (xm ..))
;;;  Remove the value (and the slot).
;;; 
;;; POP for ((xn ..) < (xm ..))
;;;  Pop (remove the first element of) the value.  If the value is
;;;  nil, return nil.
;;; 
(defun setvalue (fs path val &key (mode 'OVERWRITE))  ; returns a fs
  (cond
      ((null path)
 	 (case mode
	  (OVERWRITE val)
   	  (UNIFY (unify fs val))
	  (C-UNIFY (if fs (unify fs val) '*FAIL*))
	  (DEFINED (if fs fs '*FAIL*)) 
	  (UNDEFINED (if fs '*FAIL* nil))
	  (PUSH (append-fs-to-fs fs val))
	  (REMOVE nil)
	  (POP (pop-multi-value fs))))

         ;; if fs is *OR*, do each of the disjunction.
         ;; Return *fail* when all of the disjunction fail.
      ((and (listp fs)(eq (car fs) '*OR*))
       (or
        (list-to-value
	 (map-dolist+ (fs1 (cdr fs))
 	  (setvalue fs1 path val :mode mode)))
        '*FAIL*))

         ;; if fs is *MULTIPLE*, do each of the conjunction.
         ;; Return *fail* when any one of the disjunction fails.
      ((and (listp fs)(eq (car fs) '*MULTIPLE*))
       (let ((newvalue nil))
         (setq newvalue
           (map-dolist (fs1 (cdr fs))
 	   (setvalue fs1 path val :mode mode)))
         (if (member '*FAIL* newvalue)
             '*FAIL*
             (cons '*MULTIPLE* newvalue))))
          
         ;; else take ASSOC
      (t (let ((assoc-result (assoc (car path) fs)))
	  (if
            (null assoc-result)
	      ;; If the path doesn't exist	
	    (case mode
	      ((OVERWRITE UNIFY PUSH) (append (create-path path val) fs))
	      ((C-UNIFY DEFINED) '*FAIL*)
	      ((UNDEFINED REMOVE) fs))
	      
	       ;; If the path exists, call setvalue recursively
	    (let ((rec-result (setvalue (second assoc-result)
					(cdr path) val :mode mode)))
              (cond ((eq rec-result '*FAIL*) '*FAIL*)
		    ((null rec-result)(remove assoc-result fs))
	            ((cons (list (car path) rec-result)
			(remove assoc-result fs))))))))))

;;; 
;;; CREATE-PATH is used by SETVALUE
;;;  e.g. (create-path '(f1 f2) 'v1) ==> ((f1 ((f2 v1))))
;;;
(defun create-path (path val)
 (cond ((= (length path) 1)(list (list (car path) val)))
       (t (list (list (car path)(create-path (cdr path) val))))))
;;;
;;;  APPEND-FS-TO-FS appends two multiple values.
;;;
(defun append-fs-to-fs (fs1 fs2)
   (cond ((null fs1) fs2)
	 ((multi-p fs1)
	  (cond ((null fs2) fs1)
		((multi-p fs2) (cons '*MULTIPLE*
				     (cons (cdr fs2) (cdr fs1))))
		(t (cons '*MULTIPLE* (cons fs2 (cdr fs1))))))
	 (t
	  (cond ((multi-p fs2) (cons '*MULTIPLE* 
				     (cons fs2 (cdr fs1))))
	   	(t (list '*MULTIPLE* fs2 fs1))))))

;;; ___________________________________________________________________
;;; 
;;;  UNIFICATION functions
;;; ___________________________________________________________________

;;; 
;;;  UNIFY is the top level unification function.
;;; 
(defun unify (fs1 fs2) ; returns a fs or *fail*
  (cond ((null fs1) fs2)
	((null fs2) fs1)
 	((multi-p fs1) (unify*multiple* fs1 fs2))
 	((multi-p fs2) (unify*multiple* fs2 fs1))
	((or-p fs1) (unify*OR* fs1 fs2))
	((or-p fs2) (unify*OR* fs2 fs1))
	((not-p fs1) (unify*NOT* fs1 fs2))
	((not-p fs2) (unify*NOT* fs2 fs1))
     	((user-p fs1)(unify-user-values fs1 fs2))
	((user-p fs2)(unify-user-values fs2 fs1))
	((stringp fs1) (if (and (stringp fs2) (string-equal fs1 fs2)) fs1 '*fail*))
	((stringp fs2) '*fail*)
	((atom fs1) (if (eq fs1 fs2) fs2 '*fail*))
	((atom fs2) '*fail*)
	(t (unify-fs fs1 fs2))))
 	
;;;
;;; UNIFY-FS does the tree to tree (fs-to-fs) unification.
;;;
(defun unify-fs (fs1 fs2)  ; returns a new fs
  (prog (new-fs sub-fs)
    (dolist (slot-value fs1)
      (let* ((slot (car slot-value))
	     (value (second slot-value))
	     (assoc-result (assoc slot fs2)))
	(cond (assoc-result 
	       (setq sub-fs (unify value (second assoc-result)))
               (if (eq sub-fs '*fail*) (return-from unify-fs '*fail*))
   	       (push (list slot sub-fs) new-fs)
	       (setq fs2 (remove assoc-result fs2)))
	      (t
	       (push slot-value new-fs)))))
    (return (append new-fs fs2))))

;;; 				
;;; UNIFY*OR* calls UNIFY with all possible combinations
;;; of fs-list1.
;;; 
(defun unify*or* (fs1 fs2 &aux result)
   (setq result
         (append-dolist (f (cdr fs1))
	     (value-to-list (unify f fs2))))
   (setq result (remove '*fail* result))
   (if result (list-to-value result) '*fail*))

;;; 
;;;  UNIFY*MULTIPLE* takes fs1 and fs2, where fs1 is a *multiple* value.
;;;  Unify fs2 with each element of fs1.  If any one
;;;  fails, it returns *fail*.  Otherwise, return the list
;;;  of results.
;;; 
(defun unify*multiple* (fs1 fs2 &aux result)
  (setq result
      (append-dolist (f (cdr fs1))
	(multi-value-to-list (unify f fs2))))
  (if (member '*fail* result) '*fail* (list-to-multi-value result)))

;;; 
;;;  UNIFY*NOT* takes fs1 and fs2, where fs1 is a *not* value.
;;;  Unify fs2 with each element of fs1.  If any one does NOT fail,
;;;  it returns *FAIL*; If all fail, it returns fs2.
;;; 
(defun unify*not* (fs1 fs2 &aux result)
  (setq result
      (append-dolist (f (cdr fs1))
	(value-to-list (unify f fs2))))
  (setq result (remove '*FAIL* result))
  (if result '*FAIL* fs2))

;;; 
;;;  UNIFY-USER-VALUES unifies two user-defined special values.
;;; 
(defun unify-user-values (fs1 fs2)
  (apply (intern (concatenate 'string "UNIFY"
			 (symbol-name (car fs1))))
	 (list fs1 fs2)))
